home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Carp / Clan.pm < prev    next >
Encoding:
Text File  |  2009-10-24  |  8.3 KB  |  234 lines
  1.  
  2. ##
  3. ## Based on Carp.pm from Perl 5.005_03.
  4. ## Last modified 24-Oct-2009 by Steffen Beyer.
  5. ## Should be reasonably backwards compatible.
  6. ##
  7. ## This module is free software and can
  8. ## be used, modified and redistributed
  9. ## under the same terms as Perl itself.
  10. ##
  11.  
  12. @DB::args = ();    # Avoid warning "used only once" in Perl 5.003
  13.  
  14. package Carp::Clan;
  15.  
  16. use strict;
  17. use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
  18. use overload ();
  19.  
  20. # Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
  21.  
  22. # The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
  23. # the eval text and function arguments should be formatted when printed.
  24.  
  25. $MaxEvalLen = 0;     # How much eval '...text...' to show. 0 = all.
  26. $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
  27. $MaxArgNums = 8;     # How many arguments to print.        0 = all.
  28.  
  29. $Verbose = 0;        # If true then make _shortmsg call _longmsg instead.
  30.  
  31. $VERSION = '6.04';
  32.  
  33. # _longmsg() crawls all the way up the stack reporting on all the function
  34. # calls made. The error string, $error, is originally constructed from the
  35. # arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
  36. # This gets appended with the stack trace messages which are generated for
  37. # each function call on the stack.
  38.  
  39. sub _longmsg {
  40.     return (@_) if ( ref $_[0] );
  41.     local $_;        # Protect surrounding program - just in case...
  42.     my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
  43.     my $error = join( '', @_ );
  44.     my $msg   = '';
  45.     my $i     = 0;
  46.     while (
  47.         do {
  48.             {
  49.  
  50.                 package DB;
  51.                 ( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
  52.                     = caller( $i++ )
  53.             }
  54.         }
  55.         )
  56.     {
  57.         next if ( $pack eq 'Carp::Clan' );
  58.         if ( $error eq '' ) {
  59.             if ( defined $eval ) {
  60.                 $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
  61.                 $eval
  62.                     =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  63.                 substr( $eval, $MaxEvalLen ) = '...'
  64.                     if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
  65.                 if   ($require) { $sub = "require $eval"; }
  66.                 else            { $sub = "eval '$eval'"; }
  67.             }
  68.             elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
  69.             else {
  70.                 @parms = ();
  71.                 if ($hargs) {
  72.                     $push  = 0;
  73.                     @parms = @DB::args
  74.                         ;    # We may trash some of the args so we take a copy
  75.                     if ( $MaxArgNums and @parms > $MaxArgNums ) {
  76.                         $#parms = $MaxArgNums;
  77.                         pop(@parms);
  78.                         $push = 1;
  79.                     }
  80.                     for (@parms) {
  81.                         if ( defined $_ ) {
  82.                             if ( ref $_ ) {
  83.                                 $_ = overload::StrVal($_);
  84.                             }
  85.                             else {
  86.                                 unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
  87.                                     )    # Looks numeric
  88.                                 {
  89.                                     s/([\\\'])/\\$1/g;    # Escape \ and '
  90.                                     s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
  91.                                     substr( $_, $MaxArgLen ) = '...'
  92.                                         if ( $MaxArgLen
  93.                                         and length($_) > $MaxArgLen );
  94.                                     $_ = "'$_'";
  95.                                 }
  96.                             }
  97.                         }
  98.                         else { $_ = 'undef'; }
  99.                     }
  100.                     push( @parms, '...' ) if ($push);
  101.                 }
  102.                 $sub .= '(' . join( ', ', @parms ) . ')';
  103.             }
  104.             if ( $msg eq '' ) { $msg = "$sub called"; }
  105.             else              { $msg .= "\t$sub called"; }
  106.         }
  107.         else {
  108.             $msg = quotemeta($sub);
  109.             if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
  110.             else {
  111.                 if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
  112.                 else                { $msg = "$sub: $error"; }
  113.             }
  114.         }
  115.         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
  116.         $error = '';
  117.     }
  118.     $msg ||= $error;
  119.     $msg =~ tr/\0//d;  # Circumvent die's incorrect handling of NUL characters
  120.     $msg;
  121. }
  122.  
  123. # _shortmsg() is called by carp() and croak() to skip all the way up to
  124. # the top-level caller's package and report the error from there. confess()
  125. # and cluck() generate a full stack trace so they call _longmsg() to
  126. # generate that. In verbose mode _shortmsg() calls _longmsg() so you
  127. # always get a stack trace.
  128.  
  129. sub _shortmsg {
  130.     my $pattern = shift;
  131.     my $verbose = shift;
  132.     return (@_) if ( ref $_[0] );
  133.     goto &_longmsg if ( $Verbose or $verbose );
  134.     my ( $pack, $file, $line, $sub );
  135.     my $error = join( '', @_ );
  136.     my $msg   = '';
  137.     my $i     = 0;
  138.     while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
  139.         next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
  140.         if ( $error eq '' ) { $msg = "$sub() called"; }
  141.         else {
  142.             $msg = quotemeta($sub);
  143.             if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
  144.             else {
  145.                 if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
  146.                 else                { $msg = "$sub: $error"; }
  147.             }
  148.         }
  149.         $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
  150.         $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
  151.         return $msg;
  152.     }
  153.     goto &_longmsg;
  154. }
  155.  
  156. # In the two identical regular expressions (immediately after the two occurrences of
  157. # "quotemeta") above, the "\b ... \b" helps to avoid confusion between function names
  158. # which are prefixes of each other, e.g. "My::Class::print" and "My::Class::println".
  159.  
  160. # The following four functions call _longmsg() or _shortmsg() depending on
  161. # whether they should generate a full stack trace (confess() and cluck())
  162. # or simply report the caller's package (croak() and carp()), respectively.
  163. # confess() and croak() die, carp() and cluck() warn.
  164.  
  165. # Following code kept for calls with fully qualified subroutine names:
  166. # (For backward compatibility with the original Carp.pm)
  167.  
  168. sub croak {
  169.     my $callpkg = caller(0);
  170.     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
  171.     die _shortmsg( $pattern, 0, @_ );
  172. }
  173. sub confess { die _longmsg(@_); }
  174.  
  175. sub carp {
  176.     my $callpkg = caller(0);
  177.     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
  178.     warn _shortmsg( $pattern, 0, @_ );
  179. }
  180. sub cluck { warn _longmsg(@_); }
  181.  
  182. # The following method imports a different closure for every caller.
  183. # I.e., different modules can use this module at the same time
  184. # and in parallel and still use different patterns.
  185.  
  186. sub import {
  187.     my $pkg     = shift;
  188.     my $callpkg = caller(0);
  189.     my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
  190.     my $verbose = 0;
  191.     my $item;
  192.     my $file;
  193.  
  194.     for $item (@_) {
  195.         if ( $item =~ /^\d/ ) {
  196.             if ( $VERSION < $item ) {
  197.                 $file = "$pkg.pm";
  198.                 $file =~ s!::!/!g;
  199.                 $file = $INC{$file};
  200.                 die _shortmsg( '^:::', 0,
  201.                     "$pkg $item required--this is only version $VERSION ($file)"
  202.                 );
  203.             }
  204.         }
  205.         elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
  206.         else                            { $pattern = $item; }
  207.     }
  208.  
  209.    # Speed up pattern matching in Perl versions >= 5.005:
  210.    # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
  211.     if ( $] >= 5.005 ) {
  212.         eval '$pattern = qr/$pattern/;';
  213.     }
  214.     else {
  215.         eval { $pkg =~ /$pattern/; };
  216.     }
  217.     if ($@) {
  218.         $@ =~ s/\s+$//;
  219.         $@ =~ s/\s+at\s.+$//;
  220.         die _shortmsg( '^:::', 0, $@ );
  221.     }
  222.     {
  223.         local ($^W) = 0;
  224.         no strict "refs";
  225.         *{"${callpkg}::croak"}   = sub { die  _shortmsg( $pattern, $verbose, @_ ); };
  226.         *{"${callpkg}::confess"} = sub { die  _longmsg (                     @_ ); };
  227.         *{"${callpkg}::carp"}    = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
  228.         *{"${callpkg}::cluck"}   = sub { warn _longmsg (                     @_ ); };
  229.     }
  230. }
  231.  
  232. 1;
  233.  
  234.